;; PokeyPoint is an alternative to PowerPoint. It costs less, too.
;(load "/root/lisp/ucw/ucw_0.3.7/init")
;(load "/root/lisp/ucw/pokeypoint")

(in-package :it.bese.ucw)

(defapplication pokeypoint-application 
  (:url-prefix "/ucw/pokeypoint/")
  (:tal-roots *ucw-tal-root*)
  (:www-roots
   (make-pathname :name nil :type nil
		  :directory (append (pathname-directory *ucw-tal-root*)
				     (list "ucw" "pokeypoint"))
		  :defaults *ucw-tal-root*)))

;; Special tab box that uses buttons
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass tabbed-form-pane (template-component container)
  ()
  (:default-initargs
   :template-name "ucw/tabbed-form-pane.tal"
   :label-test #'string=)
  (:documentation "Variant of tabbed-pane which uses a form and buttons")
  (:metaclass standard-component-class))

(defmethod template-component-environment nconc ((tabbed-pane tabbed-form-pane))
  (make-standard-enviroment
   (list
    (cons 'panes
          (iterate
            (with current = (container.current-component tabbed-pane))
            (for (label . component) in (container.contents tabbed-pane))
            (collect (tal-env 'pane-label label
                              'pane-component component
                              'selected (eql current component)))))
    (cons 'selected-component (container.current-component tabbed-pane)))))

;; Top-level window
;;;;;;;;;;;;;;;;;;;

(defcomponent pokeypoint-window (simple-window-component)
  ((body :component simple-container :accessor body))
  (:default-initargs
    :title "PokeyPoint"
    :stylesheet "/stylesheet.css")
  (:entry-point "index.ucw"))

(defmethod render-on ((res response) (window pokeypoint-window))
  (<:h1 (<:as-html (window-component.title window)))
  (render-on res (body window)))

(defmethod shared-initialize :after ((app pokeypoint-window)
				     slot-names &rest initargs)
  "Initialize the components contained in (body APP)."
  (declare (ignore slot-names initargs))
  (let ((container (body app))
	(tab-box (make-instance 'tabbed-form-pane)))
    (setf (find-component container 'tabbed-form-pane)
	  tab-box)
    (setf (container.current-component-name container)
	  'tabbed-form-pane)
    ;; Create tab box tab
    (setf (find-component tab-box "Speaker Notes")
	  (make-instance 'edit-slide-notes :slide *my-slide*))
    (setf (find-component tab-box "Edit Slide")
	  (make-instance 'edit-slide :slide *my-slide*))
    (setf (find-component tab-box "Show Slide")
	  (make-instance 'show-slide :slide *my-slide*))
    (setf (container.current-component-name tab-box)
	  "Show Slide")))

;; Slide items
;;;;;;;;;;;;;;

(defclass item ()
  ()
  (:documentation "One bullet-point on a slide"))

(defgeneric make-item (datum)
  (:documentation "Make an item from DATUM"))

(defclass string-item (item)
  ((datum :initarg :datum :accessor datum)))

(defmethod print-object ((object string-item) stream)
  (print-unreadable-object (object stream :type t)
    (princ (datum object) stream)))

(defmethod make-item ((datum string))
  (make-instance 'string-item
		 :datum datum))

;; Item viewers
;;;;;;;;;;;;;;;

(defcomponent view-item (widget-component)
  ((item :initarg :item :accessor item)))

(defmethod render-on (res (view-item view-item))
  (<:as-html "#<unrenderable>"))

(defcomponent view-string-item (view-item)
  ((item :initarg :item :accessor item)))

(defmethod render-on (res (view-item view-string-item))
  (<:span :class "displayed-point"
	  (<:as-html (datum (item view-item)))))

;; Item editor
;;;;;;;;;;;;;;

(defcomponent edit-item (widget-component)
  ((item :initarg :item :accessor item)))

(defmethod render-on ((res response) (edit-item edit-item))
  (with-slots (datum) (item edit-item)
    (<ucw:input :type "text" :size "100" :accessor datum))
  (<:br)
  (if (can-move-up-p edit-item)
      (<ucw:input :type "submit" :value "Up"
		  :action (move-up edit-item))
      (<:input :type "submit" :value "Up"
	       :disabled "disabled"))
  (if (can-move-down-p edit-item)
      (<ucw:input :type "submit" :value "Down"
		  :action (move-down edit-item))
      (<:input :type "submit" :value "Down"
	       :disabled "disabled"))
  (<ucw:input :type "submit" :value "Delete"
	      :action (delete-item edit-item))
  (<ucw:input :type "submit" :value "Add item before"
	      :action (add-item-before edit-item))
  (<ucw:input :type "submit" :value "Add item after"
	      :action (add-item-after edit-item)))

;; Moving down

(defun can-move-down-p (edit-item)
  "Can we move the item of an EDIT-ITEM down?"
  (let* ((parent-slide (slide (parent edit-item)))
	 (index (position (item edit-item) (items parent-slide))))
    (and index
	 (< index (1- (length (items parent-slide)))))))

(defaction move-down ((edit-item edit-item))
  (let* ((parent-slide (slide (parent edit-item)))
	 (index (position (item edit-item) (items parent-slide))))
    (if (can-move-down-p (edit-item))
	(rotatef (elt (items parent-slide) index)
		 (elt (items parent-slide) (1+ index)))
	(call 'info-message :message "Can't move that down"))))

;; Moving up

(defun can-move-up-p (edit-item)
  "Can we move the item of an EDIT-ITEM up?"
  (let* ((parent-slide (slide (parent edit-item)))
	 (index (position (item edit-item) (items parent-slide))))
    (and index (> index 0))))

(defaction move-up ((edit-item edit-item))
  (let* ((parent-slide (slide (parent edit-item)))
	 (index (position (item edit-item) (items parent-slide))))
    (if (can-move-up-p edit-item)
	(rotatef (elt (items parent-slide) index)
		 (elt (items parent-slide) (1- index)))
	(call 'info-message :message "Can't move that up"))))

;; Deletion

(defaction delete-item ((edit-item edit-item))
  (let ((parent-slide (slide (parent edit-item))))
    (setf (items parent-slide)
	  (remove (item edit-item) (items parent-slide)))))

;; Adding items

(defaction add-item-before ((edit-item edit-item))
  (let* ((parent-slide (slide (parent edit-item)))
	 (index (position (item edit-item) (items parent-slide))))
    (with-slots (items) parent-slide
      (if (> index 0)
	  (setf items
		(concatenate 'vector
			     (subseq items 0 index)
			     (vector (make-item ""))
			     (subseq items index)))
	  (setf items
		(concatenate 'vector
			     (vector (make-item ""))
			     items))))))

(defaction add-item-after ((edit-item edit-item))
  (let* ((parent-slide (slide (parent edit-item)))
	 (index (position (item edit-item) (items parent-slide))))
    (with-slots (items) parent-slide
      (if (< index (1- (length items)))
	  (setf items
		(concatenate 'vector
			     (subseq items 0 index)
			     (vector (make-item ""))
			     (subseq items index)))
	  (setf items
		(concatenate 'vector
			     items
			     (vector (make-item ""))))))))

;; Slide class: represents one slide
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass slide ()
  ((title :initarg :title :accessor title)
   (items :initarg :items :accessor items)
   (notes :initarg :notes :accessor notes :initform ""))
  (:documentation "A slide in the show"))

(defmethod shared-initialize :after ((object slide)
				     slot-names &rest initargs)
  (declare (ignore slot-names initargs))
  (setf (items object)
	(coerce (mapcar #'make-item (items object))
		'vector)))

(defmethod print-object ((slide slide) stream)
  (print-unreadable-object (slide stream :type t)
    (format stream "~S [~D]"
	    (title slide)
	    (length (items slide)))))

(defparameter *my-slide*
  (make-instance 'slide
		 :title "PokeyPoint"
		 :items '("Web-based"
			  "Open source"
			  "Doesn't suck as much as PowerPoint"
			  "NO ANIMATIONS OR SOUND EFFECTS")))

(defparameter *slide-two*
  (make-instance 'slide
		 :title "Another slide"
		 :items '("Look at the pretty points!"
			  "Here's another one."
			  "And yet another, for a grand total of three")))

;;; Slide presentations
;;;;;;;;;;;;;;;;;;;;;;;
;
;(defpresentation slide-viewer (object-presentation)
;  ((string :label "Title" :slot-name 'title)
;   (some-objects :label "Points" :slot-name 'items
;                 :presentation 'item-viwer)))
;
;(defpresentation item-viewer (inline-object-presentation)
;  ((string :slot-name 'datum)))

;; Slide show object
;;;;;;;;;;;;;;;;;;;;

(defclass slide-show ()
  ((title :initarg :title :accessor title)
   (author :initarg :author :accessor author)
   (slides :initarg :slides :accessor slides))
  (:documentation "A top-level slide show"))

(defmethod print-object ((show slide-show) stream)
  (print-unreadable-object (show stream :type t)
    (format stream "~S (~A) [~D]"
	    (title show)
	    (author show)
	    (length (slides show)))))

(defparameter *show*
  (make-instance 'slide-show
		 :title "PokeyPoint: A less sucky PowerPoint alternative"
		 :author "Peter Scott"
		 :slides (list *my-slide* *slide-two*)))

;; Slide viewer
;;;;;;;;;;;;;;;

(defcomponent show-slide (widget-component)
  ((slide :initarg :slide :accessor slide)))

(defmethod render-on ((res response) (show-slide show-slide))
  (with-slots (title items) (slide show-slide)
    (<:h1 (<:as-html title))
    (<:ul (loop for item across items
		do (let ((viewer
			  (make-instance 'view-string-item
					 :item item
					 :parent show-slide)))
		     (setf (component.place viewer) (make-place viewer))
		     (<:li (render-on res viewer)))))
    (<:p (<ucw:a :action (switch-component (parent show-slide)
					   "Edit Slide")
		 "Edit"))))

;; Slide editor
;;;;;;;;;;;;;;;

(defcomponent edit-slide (widget-component)
  ((slide :initarg :slide :accessor slide)))

(defmethod render-on ((res response) (edit-slide edit-slide))
  (with-slots (title items) (slide edit-slide)
    (<:p "Title: "
	 (<ucw:input :type "text" :size "100" :accessor title))
    (<:p (<:b "Items"))
    (<:p (loop for item across items
	       do (let ((viewer (make-instance 'edit-item
					       :item item
					       :parent edit-slide)))
		    (setf (component.place viewer) (make-place viewer))
		    (render-on res viewer))
	       do (<:br)))))

;; Slide notes editor
;;;;;;;;;;;;;;;;;;;;;

(defcomponent edit-slide-notes (widget-component)
  ((slide :initarg :slide :accessor slide)))

(defmethod render-on ((res response) (edit-slide-notes edit-slide-notes))
  (with-slots (title notes) (slide edit-slide-notes)
    (<:h1 (<:as-html title))
    (<ucw:textarea :accessor notes
		   :rows 20 :cols 100)))

;; Current slide
;;;;;;;;;;;;;;;;

;(defcomponent current-slide (task-component)
;  ((slide :initarg :slide :accessor slide)))
;
;(defaction start ((slide current-slide))
;  (call 'show-slide :slide (slide slide)))